home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / f2c-9510.000 / f2c-9510 / f2c-951007-libs-1.1 / src / io.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-10-07  |  29.8 KB  |  1,506 lines
  1. /****************************************************************
  2. Copyright 1990, 1991, 1993, 1994 by AT&T Bell Laboratories and Bellcore.
  3.  
  4. Permission to use, copy, modify, and distribute this software
  5. and its documentation for any purpose and without fee is hereby
  6. granted, provided that the above copyright notice appear in all
  7. copies and that both that the copyright notice and this
  8. permission notice and warranty disclaimer appear in supporting
  9. documentation, and that the names of AT&T Bell Laboratories or
  10. Bellcore or any of their entities not be used in advertising or
  11. publicity pertaining to distribution of the software without
  12. specific, written prior permission.
  13.  
  14. AT&T and Bellcore disclaim all warranties with regard to this
  15. software, including all implied warranties of merchantability
  16. and fitness.  In no event shall AT&T or Bellcore be liable for
  17. any special, indirect or consequential damages or any damages
  18. whatsoever resulting from loss of use, data or profits, whether
  19. in an action of contract, negligence or other tortious action,
  20. arising out of or in connection with the use or performance of
  21. this software.
  22. ****************************************************************/
  23.  
  24. /* Routines to generate code for I/O statements.
  25.    Some corrections and improvements due to David Wasley, U. C. Berkeley
  26. */
  27.  
  28. /* TEMPORARY */
  29. #define TYIOINT TYLONG
  30. #define SZIOINT SZLONG
  31.  
  32. #include "defs.h"
  33. #include "names.h"
  34. #include "iob.h"
  35.  
  36. extern int inqmask;
  37.  
  38. static void dofclose Argdcl((void));
  39. static void dofinquire Argdcl((void));
  40. static void dofmove Argdcl((char*));
  41. static void dofopen Argdcl((void));
  42. static void doiolist Argdcl((chainp));
  43. static void ioset Argdcl((int, int, expptr));
  44. static void ioseta Argdcl((int, Addrp));
  45. static void iosetc Argdcl((int, expptr));
  46. static void iosetip Argdcl((int, int));
  47. static void iosetlc Argdcl((int, int, int));
  48. static void putio Argdcl((expptr, expptr));
  49. static void putiocall Argdcl((expptr));
  50.  
  51. iob_data *iob_list;
  52. Addrp io_structs[9];
  53.  
  54. LOCAL char ioroutine[12];
  55.  
  56. LOCAL long ioendlab;
  57. LOCAL long ioerrlab;
  58. LOCAL int endbit;
  59. LOCAL int errbit;
  60. LOCAL long jumplab;
  61. LOCAL long skiplab;
  62. LOCAL int ioformatted;
  63. LOCAL int statstruct = NO;
  64. LOCAL struct Labelblock *skiplabel;
  65. Addrp ioblkp;
  66.  
  67. #define UNFORMATTED 0
  68. #define FORMATTED 1
  69. #define LISTDIRECTED 2
  70. #define NAMEDIRECTED 3
  71.  
  72. #define V(z)    ioc[z].iocval
  73.  
  74. #define IOALL 07777
  75.  
  76. LOCAL struct Ioclist
  77. {
  78.     char *iocname;
  79.     int iotype;
  80.     expptr iocval;
  81. }
  82. ioc[ ] =
  83. {
  84.     { "", 0 },
  85.     { "unit", IOALL },
  86.     { "fmt", M(IOREAD) | M(IOWRITE) },
  87.     { "err", IOALL },
  88.     { "end", M(IOREAD) },
  89.     { "iostat", IOALL },
  90.     { "rec", M(IOREAD) | M(IOWRITE) },
  91.     { "recl", M(IOOPEN) | M(IOINQUIRE) },
  92.     { "file", M(IOOPEN) | M(IOINQUIRE) },
  93.     { "status", M(IOOPEN) | M(IOCLOSE) },
  94.     { "access", M(IOOPEN) | M(IOINQUIRE) },
  95.     { "form", M(IOOPEN) | M(IOINQUIRE) },
  96.     { "blank", M(IOOPEN) | M(IOINQUIRE) },
  97.     { "exist", M(IOINQUIRE) },
  98.     { "opened", M(IOINQUIRE) },
  99.     { "number", M(IOINQUIRE) },
  100.     { "named", M(IOINQUIRE) },
  101.     { "name", M(IOINQUIRE) },
  102.     { "sequential", M(IOINQUIRE) },
  103.     { "direct", M(IOINQUIRE) },
  104.     { "formatted", M(IOINQUIRE) },
  105.     { "unformatted", M(IOINQUIRE) },
  106.     { "nextrec", M(IOINQUIRE) },
  107.     { "nml", M(IOREAD) | M(IOWRITE) }
  108. };
  109.  
  110. #define NIOS (sizeof(ioc)/sizeof(struct Ioclist) - 1)
  111.  
  112. /* #define IOSUNIT 1 */
  113. /* #define IOSFMT 2 */
  114. #define IOSERR 3
  115. #define IOSEND 4
  116. #define IOSIOSTAT 5
  117. #define IOSREC 6
  118. #define IOSRECL 7
  119. #define IOSFILE 8
  120. #define IOSSTATUS 9
  121. #define IOSACCESS 10
  122. #define IOSFORM 11
  123. #define IOSBLANK 12
  124. #define IOSEXISTS 13
  125. #define IOSOPENED 14
  126. #define IOSNUMBER 15
  127. #define IOSNAMED 16
  128. #define IOSNAME 17
  129. #define IOSSEQUENTIAL 18
  130. #define IOSDIRECT 19
  131. #define IOSFORMATTED 20
  132. #define IOSUNFORMATTED 21
  133. #define IOSNEXTREC 22
  134. #define IOSNML 23
  135.  
  136. #define IOSTP V(IOSIOSTAT)
  137.  
  138.  
  139. /* offsets in generated structures */
  140.  
  141. #define SZFLAG SZIOINT
  142.  
  143. /* offsets for external READ and WRITE statements */
  144.  
  145. #define XERR 0
  146. #define XUNIT    SZFLAG
  147. #define XEND    SZFLAG + SZIOINT
  148. #define XFMT    2*SZFLAG + SZIOINT
  149. #define XREC    2*SZFLAG + SZIOINT + SZADDR
  150.  
  151. /* offsets for internal READ and WRITE statements */
  152.  
  153. #define XIUNIT    SZFLAG
  154. #define XIEND    SZFLAG + SZADDR
  155. #define XIFMT    2*SZFLAG + SZADDR
  156. #define XIRLEN    2*SZFLAG + 2*SZADDR
  157. #define XIRNUM    2*SZFLAG + 2*SZADDR + SZIOINT
  158. #define XIREC    2*SZFLAG + 2*SZADDR + 2*SZIOINT
  159.  
  160. /* offsets for OPEN statements */
  161.  
  162. #define XFNAME    SZFLAG + SZIOINT
  163. #define XFNAMELEN    SZFLAG + SZIOINT + SZADDR
  164. #define XSTATUS    SZFLAG + 2*SZIOINT + SZADDR
  165. #define XACCESS    SZFLAG + 2*SZIOINT + 2*SZADDR
  166. #define XFORMATTED    SZFLAG + 2*SZIOINT + 3*SZADDR
  167. #define XRECLEN    SZFLAG + 2*SZIOINT + 4*SZADDR
  168. #define XBLANK    SZFLAG + 3*SZIOINT + 4*SZADDR
  169.  
  170. /* offset for CLOSE statement */
  171.  
  172. #define XCLSTATUS    SZFLAG + SZIOINT
  173.  
  174. /* offsets for INQUIRE statement */
  175.  
  176. #define XFILE    SZFLAG + SZIOINT
  177. #define XFILELEN    SZFLAG + SZIOINT + SZADDR
  178. #define XEXISTS    SZFLAG + 2*SZIOINT + SZADDR
  179. #define XOPEN    SZFLAG + 2*SZIOINT + 2*SZADDR
  180. #define XNUMBER    SZFLAG + 2*SZIOINT + 3*SZADDR
  181. #define XNAMED    SZFLAG + 2*SZIOINT + 4*SZADDR
  182. #define XNAME    SZFLAG + 2*SZIOINT + 5*SZADDR
  183. #define XNAMELEN    SZFLAG + 2*SZIOINT + 6*SZADDR
  184. #define XQACCESS    SZFLAG + 3*SZIOINT + 6*SZADDR
  185. #define XQACCLEN    SZFLAG + 3*SZIOINT + 7*SZADDR
  186. #define XSEQ    SZFLAG + 4*SZIOINT + 7*SZADDR
  187. #define XSEQLEN    SZFLAG + 4*SZIOINT + 8*SZADDR
  188. #define XDIRECT    SZFLAG + 5*SZIOINT + 8*SZADDR
  189. #define XDIRLEN    SZFLAG + 5*SZIOINT + 9*SZADDR
  190. #define XFORM    SZFLAG + 6*SZIOINT + 9*SZADDR
  191. #define XFORMLEN    SZFLAG + 6*SZIOINT + 10*SZADDR
  192. #define XFMTED    SZFLAG + 7*SZIOINT + 10*SZADDR
  193. #define XFMTEDLEN    SZFLAG + 7*SZIOINT + 11*SZADDR
  194. #define XUNFMT    SZFLAG + 8*SZIOINT + 11*SZADDR
  195. #define XUNFMTLEN    SZFLAG + 8*SZIOINT + 12*SZADDR
  196. #define XQRECL    SZFLAG + 9*SZIOINT + 12*SZADDR
  197. #define XNEXTREC    SZFLAG + 9*SZIOINT + 13*SZADDR
  198. #define XQBLANK    SZFLAG + 9*SZIOINT + 14*SZADDR
  199. #define XQBLANKLEN    SZFLAG + 9*SZIOINT + 15*SZADDR
  200.  
  201. LOCAL char *cilist_names[] = {
  202.     "cilist",
  203.     "cierr",
  204.     "ciunit",
  205.     "ciend",
  206.     "cifmt",
  207.     "cirec"
  208.     };
  209. LOCAL char *icilist_names[] = {
  210.     "icilist",
  211.     "icierr",
  212.     "iciunit",
  213.     "iciend",
  214.     "icifmt",
  215.     "icirlen",
  216.     "icirnum"
  217.     };
  218. LOCAL char *olist_names[] = {
  219.     "olist",
  220.     "oerr",
  221.     "ounit",
  222.     "ofnm",
  223.     "ofnmlen",
  224.     "osta",
  225.     "oacc",
  226.     "ofm",
  227.     "orl",
  228.     "oblnk"
  229.     };
  230. LOCAL char *cllist_names[] = {
  231.     "cllist",
  232.     "cerr",
  233.     "cunit",
  234.     "csta"
  235.     };
  236. LOCAL char *alist_names[] = {
  237.     "alist",
  238.     "aerr",
  239.     "aunit"
  240.     };
  241. LOCAL char *inlist_names[] = {
  242.     "inlist",
  243.     "inerr",
  244.     "inunit",
  245.     "infile",
  246.     "infilen",
  247.     "inex",
  248.     "inopen",
  249.     "innum",
  250.     "innamed",
  251.     "inname",
  252.     "innamlen",
  253.     "inacc",
  254.     "inacclen",
  255.     "inseq",
  256.     "inseqlen",
  257.     "indir",
  258.     "indirlen",
  259.     "infmt",
  260.     "infmtlen",
  261.     "inform",
  262.     "informlen",
  263.     "inunf",
  264.     "inunflen",
  265.     "inrecl",
  266.     "innrec",
  267.     "inblank",
  268.     "inblanklen"
  269.     };
  270.  
  271. LOCAL char **io_fields;
  272.  
  273. #define zork(n,t) n, sizeof(n)/sizeof(char *) - 1, t
  274.  
  275. LOCAL io_setup io_stuff[] = {
  276.     zork(cilist_names, TYCILIST),    /* external read/write */
  277.     zork(inlist_names, TYINLIST),    /* inquire */
  278.     zork(olist_names,  TYOLIST),    /* open */
  279.     zork(cllist_names, TYCLLIST),    /* close */
  280.     zork(alist_names,  TYALIST),    /* rewind */
  281.     zork(alist_names,  TYALIST),    /* backspace */
  282.     zork(alist_names,  TYALIST),    /* endfile */
  283.     zork(icilist_names,TYICILIST),    /* internal read */
  284.     zork(icilist_names,TYICILIST)    /* internal write */
  285.     };
  286.  
  287. #undef zork
  288.  
  289.  int
  290. #ifdef KR_headers
  291. fmtstmt(lp)
  292.     register struct Labelblock *lp;
  293. #else
  294. fmtstmt(register struct Labelblock *lp)
  295. #endif
  296. {
  297.     if(lp == NULL)
  298.     {
  299.         execerr("unlabeled format statement" , CNULL);
  300.         return(-1);
  301.     }
  302.     if(lp->labtype == LABUNKNOWN)
  303.     {
  304.         lp->labtype = LABFORMAT;
  305.         lp->labelno = newlabel();
  306.     }
  307.     else if(lp->labtype != LABFORMAT)
  308.     {
  309.         execerr("bad format number", CNULL);
  310.         return(-1);
  311.     }
  312.     return(lp->labelno);
  313. }
  314.  
  315.  
  316.  void
  317. #ifdef KR_headers
  318. setfmt(lp)
  319.     struct Labelblock *lp;
  320. #else
  321. setfmt(struct Labelblock *lp)
  322. #endif
  323. {
  324.     int n, parity;
  325.     char *s0;
  326.     register char *s, *se, *t;
  327.     register k;
  328.  
  329.     s0 = s = lexline(&n);
  330.     se = t = s + n;
  331.  
  332.     /* warn of trivial errors, e.g. "  11 CONTINUE" (one too few spaces) */
  333.     /* following FORMAT... */
  334.  
  335.     if (n <= 0)
  336.         warn("No (...) after FORMAT");
  337.     else if (*s != '(')
  338.         warni("%c rather than ( after FORMAT", *s);
  339.     else if (se[-1] != ')') {
  340.         *se = 0;
  341.         while(--t > s && *t != ')') ;
  342.         if (t <= s)
  343.             warn("No ) at end of FORMAT statement");
  344.         else if (se - t > 30)
  345.             warn1("Extraneous text at end of FORMAT: ...%s", se-12);
  346.         else
  347.             warn1("Extraneous text at end of FORMAT: %s", t+1);
  348.         t = se;
  349.         }
  350.  
  351.     /* fix MYQUOTES (\002's) and \\'s */
  352.  
  353.     parity = 1;
  354.     while(s < se)
  355.         switch(*s++) {
  356.             case 2:
  357.                 if ((parity ^= 1) && *s == 2) {
  358.                     t -= 2;
  359.                     ++s;
  360.                     }
  361.                 else
  362.                     t += 3;
  363.                 break;
  364.             case '"':
  365.             case '\\':
  366.                 t++; break;
  367.             }
  368.     s = s0;
  369.     parity = 1;
  370.     if (lp) {
  371.         lp->fmtstring = t = mem((int)(t - s + 1), 0);
  372.         while(s < se)
  373.             switch(k = *s++) {
  374.                 case 2:
  375.                     if ((parity ^= 1) && *s == 2)
  376.                         s++;
  377.                     else {
  378.                         t[0] = '\\';
  379.                         t[1] = '0';
  380.                         t[2] = '0';
  381.                         t[3] = '2';
  382.                         t += 4;
  383.                         }
  384.                     break;
  385.                 case '"':
  386.                 case '\\':
  387.                     *t++ = '\\';
  388.                     /* no break */
  389.                 default:
  390.                     *t++ = k;
  391.                 }
  392.         *t = 0;
  393.         }
  394.     flline();
  395. }
  396.  
  397.  
  398.  void
  399. #ifdef KR_headers
  400. startioctl()
  401. #else
  402. startioctl()
  403. #endif
  404. {
  405.     register int i;
  406.  
  407.     inioctl = YES;
  408.     nioctl = 0;
  409.     ioformatted = UNFORMATTED;
  410.     for(i = 1 ; i<=NIOS ; ++i)
  411.         V(i) = NULL;
  412. }
  413.  
  414.  static long
  415. newiolabel(Void) {
  416.     long rv;
  417.     rv = ++lastiolabno;
  418.     skiplabel = mklabel(rv);
  419.     skiplabel->labdefined = 1;
  420.     return rv;
  421.     }
  422.  
  423.  void
  424. endioctl(Void)
  425. {
  426.     int i;
  427.     expptr p;
  428.     struct io_setup *ios;
  429.  
  430.     inioctl = NO;
  431.  
  432.     /* set up for error recovery */
  433.  
  434.     ioerrlab = ioendlab = skiplab = jumplab = 0;
  435.  
  436.     if(p = V(IOSEND))
  437.         if(ISICON(p))
  438.             execlab(ioendlab = p->constblock.Const.ci);
  439.         else
  440.             err("bad end= clause");
  441.  
  442.     if(p = V(IOSERR))
  443.         if(ISICON(p))
  444.             execlab(ioerrlab = p->constblock.Const.ci);
  445.         else
  446.             err("bad err= clause");
  447.  
  448.     if(IOSTP)
  449.         if(IOSTP->tag!=TADDR || ! ISINT(IOSTP->addrblock.vtype) )
  450.         {
  451.             err("iostat must be an integer variable");
  452.             frexpr(IOSTP);
  453.             IOSTP = NULL;
  454.         }
  455.  
  456.     if(iostmt == IOREAD)
  457.     {
  458.         if(IOSTP)
  459.         {
  460.             if(ioerrlab && ioendlab && ioerrlab==ioendlab)
  461.                 jumplab = ioerrlab;
  462.             else
  463.                 skiplab = jumplab = newiolabel();
  464.         }
  465.         else    {
  466.             if(ioerrlab && ioendlab && ioerrlab!=ioendlab)
  467.             {
  468.                 IOSTP = (expptr) mktmp(TYINT, ENULL);
  469.                 skiplab = jumplab = newiolabel();
  470.             }
  471.             else
  472.                 jumplab = (ioerrlab ? ioerrlab : ioendlab);
  473.         }
  474.     }
  475.     else if(iostmt == IOWRITE)
  476.     {
  477.         if(IOSTP && !ioerrlab)
  478.             skiplab = jumplab = newiolabel();
  479.         else
  480.             jumplab = ioerrlab;
  481.     }
  482.     else
  483.         jumplab = ioerrlab;
  484.  
  485.     endbit = IOSTP!=NULL || ioendlab!=0;    /* for use in startrw() */
  486.     errbit = IOSTP!=NULL || ioerrlab!=0;
  487.     if (jumplab && !IOSTP)
  488.         IOSTP = (expptr) mktmp(TYINT, ENULL);
  489.  
  490.     if(iostmt!=IOREAD && iostmt!=IOWRITE)
  491.     {
  492.         ios = io_stuff + iostmt;
  493.         io_fields = ios->fields;
  494.         ioblkp = io_structs[iostmt];
  495.         if(ioblkp == NULL)
  496.             io_structs[iostmt] = ioblkp =
  497.                 autovar(1, ios->type, ENULL, "");
  498.         ioset(TYIOINT, XERR, ICON(errbit));
  499.     }
  500.  
  501.     switch(iostmt)
  502.     {
  503.     case IOOPEN:
  504.         dofopen();
  505.         break;
  506.  
  507.     case IOCLOSE:
  508.         dofclose();
  509.         break;
  510.  
  511.     case IOINQUIRE:
  512.         dofinquire();
  513.         break;
  514.  
  515.     case IOBACKSPACE:
  516.         dofmove("f_back");
  517.         break;
  518.  
  519.     case IOREWIND:
  520.         dofmove("f_rew");
  521.         break;
  522.  
  523.     case IOENDFILE:
  524.         dofmove("f_end");
  525.         break;
  526.  
  527.     case IOREAD:
  528.     case IOWRITE:
  529.         startrw();
  530.         break;
  531.  
  532.     default:
  533.         fatali("impossible iostmt %d", iostmt);
  534.     }
  535.     for(i = 1 ; i<=NIOS ; ++i)
  536.         if(i!=IOSIOSTAT && V(i)!=NULL)
  537.             frexpr(V(i));
  538. }
  539.  
  540.  
  541.  int
  542. iocname(Void)
  543. {
  544.     register int i;
  545.     int found, mask;
  546.  
  547.     found = 0;
  548.     mask = M(iostmt);
  549.     for(i = 1 ; i <= NIOS ; ++i)
  550.         if(!strcmp(ioc[i].iocname, token))
  551.             if(ioc[i].iotype & mask)
  552.                 return(i);
  553.             else {
  554.                 found = i;
  555.                 break;
  556.                 }
  557.     if(found) {
  558.         if (iostmt == IOOPEN && !strcmp(ioc[i].iocname, "name")) {
  559.             NOEXT("open with \"name=\" treated as \"file=\"");
  560.             for(i = 1; strcmp(ioc[i].iocname, "file"); i++);
  561.             return i;
  562.             }
  563.         errstr("invalid control %s for statement", ioc[found].iocname);
  564.         }
  565.     else
  566.         errstr("unknown iocontrol %s", token);
  567.     return(IOSBAD);
  568. }
  569.  
  570.  
  571.  void
  572. #ifdef KR_headers
  573. ioclause(n, p)
  574.     register int n;
  575.     register expptr p;
  576. #else
  577. ioclause(register int n, register expptr p)
  578. #endif
  579. {
  580.     struct Ioclist *iocp;
  581.  
  582.     ++nioctl;
  583.     if(n == IOSBAD)
  584.         return;
  585.     if(n == IOSPOSITIONAL)
  586.         {
  587.         n = nioctl;
  588.         if (n == IOSFMT) {
  589.             if (iostmt == IOOPEN) {
  590.                 n = IOSFILE;
  591.                 NOEXT("file= specifier omitted from open");
  592.                 }
  593.             else if (iostmt < IOREAD)
  594.                 goto illegal;
  595.             }
  596.         else if(n > IOSFMT)
  597.             {
  598.  illegal:
  599.             err("illegal positional iocontrol");
  600.             return;
  601.             }
  602.         }
  603.     else if (n == IOSNML)
  604.         n = IOSFMT;
  605.  
  606.     if(p == NULL)
  607.     {
  608.         if(n == IOSUNIT)
  609.             p = (expptr) (iostmt==IOREAD ? IOSTDIN : IOSTDOUT);
  610.         else if(n != IOSFMT)
  611.         {
  612.             err("illegal * iocontrol");
  613.             return;
  614.         }
  615.     }
  616.     if(n == IOSFMT)
  617.         ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED);
  618.  
  619.     iocp = & ioc[n];
  620.     if(iocp->iocval == NULL)
  621.     {
  622.         if(n!=IOSFMT && ( n!=IOSUNIT || (p && p->headblock.vtype!=TYCHAR) ) )
  623.             p = fixtype(p);
  624.         else if (p && p->tag == TPRIM
  625.                && p->primblock.namep->vclass == CLUNKNOWN) {
  626.             /* kludge made necessary by attempt to infer types
  627.              * for untyped external parameters: given an error
  628.              * in calling sequences, an integer argument might
  629.              * tentatively be assumed TYCHAR; this would otherwise
  630.              * be corrected too late in startrw after startrw
  631.              * had decided this to be an internal file.
  632.              */
  633.             vardcl(p->primblock.namep);
  634.             p->primblock.vtype = p->primblock.namep->vtype;
  635.             }
  636.         iocp->iocval = p;
  637.     }
  638.     else
  639.         errstr("iocontrol %s repeated", iocp->iocname);
  640. }
  641.  
  642. /* io list item */
  643.  
  644.  void
  645. #ifdef KR_headers
  646. doio(list)
  647.     chainp list;
  648. #else
  649. doio(chainp list)
  650. #endif
  651. {
  652.     if(ioformatted == NAMEDIRECTED)
  653.     {
  654.         if(list)
  655.             err("no I/O list allowed in NAMELIST read/write");
  656.     }
  657.     else
  658.     {
  659.         doiolist(list);
  660.         ioroutine[0] = 'e';
  661.         if (skiplab)
  662.             jumplab = 0;
  663.         putiocall( call0(TYINT, ioroutine) );
  664.     }
  665. }
  666.  
  667.  
  668.  
  669.  
  670.  
  671.  LOCAL void
  672. #ifdef KR_headers
  673. doiolist(p0)
  674.     chainp p0;
  675. #else
  676. doiolist(chainp p0)
  677. #endif
  678. {
  679.     chainp p;
  680.     register tagptr q;
  681.     register expptr qe;
  682.     register Namep qn;
  683.     Addrp tp;
  684.     int range;
  685.     extern char *ohalign;
  686.  
  687.     for (p = p0 ; p ; p = p->nextp)
  688.     {
  689.         q = (tagptr)p->datap;
  690.         if(q->tag == TIMPLDO)
  691.         {
  692.             exdo(range=newlabel(), (Namep)0,
  693.                 q->impldoblock.impdospec);
  694.             doiolist(q->impldoblock.datalist);
  695.             enddo(range);
  696.             free( (charptr) q);
  697.         }
  698.         else    {
  699.             if(q->tag==TPRIM && q->primblock.argsp==NULL
  700.                 && q->primblock.namep->vdim!=NULL)
  701.             {
  702.                 vardcl(qn = q->primblock.namep);
  703.                 if(qn->vdim->nelt) {
  704.                     putio( fixtype(cpexpr(qn->vdim->nelt)),
  705.                         (expptr)mkscalar(qn) );
  706.                     qn->vlastdim = 0;
  707.                     }
  708.                 else
  709.                     err("attempt to i/o array of unknown size");
  710.             }
  711.             else if(q->tag==TPRIM && q->primblock.argsp==NULL &&
  712.                 (qe = (expptr) memversion(q->primblock.namep)) )
  713.                 putio(ICON(1),qe);
  714.             else if (ISCONST(q) && q->constblock.vtype == TYCHAR) {
  715.                 halign = 0;
  716.                 putio(ICON(1), qe = fixtype(cpexpr(q)));
  717.                 halign = ohalign;
  718.                 }
  719.             else if(((qe = fixtype(cpexpr(q)))->tag==TADDR &&
  720.                 (qe->addrblock.uname_tag != UNAM_CONST ||
  721.                 !ISCOMPLEX(qe -> addrblock.vtype))) ||
  722.                 (qe -> tag == TCONST && !ISCOMPLEX(qe ->
  723.                 headblock.vtype))) {
  724.                 if (qe -> tag == TCONST)
  725.                     qe = (expptr) putconst((Constp)qe);
  726.                 putio(ICON(1), qe);
  727.             }
  728.             else if(qe->headblock.vtype != TYERROR)
  729.             {
  730.                 if(iostmt == IOWRITE)
  731.                 {
  732.                     expptr qvl;
  733.                     qvl = NULL;
  734.                     if( ISCHAR(qe) )
  735.                     {
  736.                         qvl = (expptr)
  737.                             cpexpr(qe->headblock.vleng);
  738.                         tp = mktmp(qe->headblock.vtype,
  739.                             ICON(lencat(qe)));
  740.                     }
  741.                     else
  742.                         tp = mktmp(qe->headblock.vtype,
  743.                             qe->headblock.vleng);
  744.                     puteq( cpexpr((expptr)tp), qe);
  745.                     if(qvl)    /* put right length on block */
  746.                     {
  747.                         frexpr(tp->vleng);
  748.                         tp->vleng = qvl;
  749.                     }
  750.                     putio(ICON(1), (expptr)tp);
  751.                 }
  752.                 else
  753.                     err("non-left side in READ list");
  754.             }
  755.             frexpr(q);
  756.         }
  757.     }
  758.     frchain( &p0 );
  759. }
  760.  
  761.  int iocalladdr = TYADDR;    /* for fixing TYADDR in saveargtypes */
  762.  int typeconv[TYERROR+1] = {
  763. #ifdef TYQUAD
  764.         0, 1, 11, 2, 3, 14, 4, 5, 6, 7, 12, 13, 8, 9, 10, 15
  765. #else
  766.         0, 1, 11, 2, 3,     4, 5, 6, 7, 12, 13, 8, 9, 10, 14
  767. #endif
  768.         };
  769.  
  770.  LOCAL void
  771. #ifdef KR_headers
  772. putio(nelt, addr)
  773.     expptr nelt;
  774.     register expptr addr;
  775. #else
  776. putio(expptr nelt, register expptr addr)
  777. #endif
  778. {
  779.     int type;
  780.     register expptr q;
  781.     register Addrp c = 0;
  782.  
  783.     type = addr->headblock.vtype;
  784.     if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) )
  785.     {
  786.         nelt = mkexpr(OPSTAR, ICON(2), nelt);
  787.         type -= (TYCOMPLEX-TYREAL);
  788.     }
  789.  
  790.     /* pass a length with every item.  for noncharacter data, fake one */
  791.     if(type != TYCHAR)
  792.     {
  793.  
  794.         if( ISCONST(addr) )
  795.             addr = (expptr) putconst((Constp)addr);
  796.         c = ALLOC(Addrblock);
  797.         c->tag = TADDR;
  798.         c->vtype = TYLENG;
  799.         c->vstg = STGAUTO;
  800.         c->ntempelt = 1;
  801.         c->isarray = 1;
  802.         c->memoffset = ICON(0);
  803.         c->uname_tag = UNAM_IDENT;
  804.         c->charleng = 1;
  805.         sprintf(c->user.ident, "(ftnlen)sizeof(%s)", typename[type]);
  806.         addr = mkexpr(OPCHARCAST, addr, ENULL);
  807.         }
  808.  
  809.     nelt = fixtype( mkconv(tyioint,nelt) );
  810.     if(ioformatted == LISTDIRECTED) {
  811.         expptr mc = mkconv(tyioint, ICON(typeconv[type]));
  812.         q = c    ? call4(TYINT, "do_lio", mc, nelt, addr, (expptr)c)
  813.             : call3(TYINT, "do_lio", mc, nelt, addr);
  814.         }
  815.     else {
  816.         char *s = ioformatted==FORMATTED ? "do_fio" : "do_uio";
  817.         q = c    ? call3(TYINT, s, nelt, addr, (expptr)c)
  818.             : call2(TYINT, s, nelt, addr);
  819.         }
  820.     iocalladdr = TYCHAR;
  821.     putiocall(q);
  822.     iocalladdr = TYADDR;
  823. }
  824.  
  825.  
  826.  
  827.  void
  828. endio(Void)
  829. {
  830.     if(skiplab)
  831.     {
  832.         if (ioformatted != NAMEDIRECTED)
  833.             p1_label((long)(skiplabel - labeltab));
  834.         if(ioendlab) {
  835.             exif( mkexpr(OPLT, cpexpr(IOSTP), ICON(0)));
  836.             exgoto(execlab(ioendlab));
  837.             exendif();
  838.             }
  839.         if(ioerrlab) {
  840.             exif( mkexpr(iostmt==IOREAD||iostmt==IOWRITE
  841.                     ? OPGT : OPNE,
  842.                 cpexpr(IOSTP), ICON(0)));
  843.             exgoto(execlab(ioerrlab));
  844.             exendif();
  845.             }
  846.     }
  847.  
  848.     if(IOSTP)
  849.         frexpr(IOSTP);
  850. }
  851.  
  852.  
  853.  
  854.  LOCAL void
  855. #ifdef KR_headers
  856. putiocall(q)
  857.     register expptr q;
  858. #else
  859. putiocall(register expptr q)
  860. #endif
  861. {
  862.     int tyintsave;
  863.  
  864.     tyintsave = tyint;
  865.     tyint = tyioint;    /* for -I2 and -i2 */
  866.  
  867.     if(IOSTP)
  868.     {
  869.         q->headblock.vtype = TYINT;
  870.         q = fixexpr((Exprp)mkexpr(OPASSIGN, cpexpr(IOSTP), q));
  871.     }
  872.     putexpr(q);
  873.     if(jumplab) {
  874.         exif(mkexpr(OPNE, cpexpr(IOSTP), ICON(0)));
  875.         exgoto(execlab(jumplab));
  876.         exendif();
  877.         }
  878.     tyint = tyintsave;
  879. }
  880.  
  881.  void
  882. #ifdef KR_headers
  883. fmtname(np, q)
  884.     Namep np;
  885.     register Addrp q;
  886. #else
  887. fmtname(Namep np, register Addrp q)
  888. #endif
  889. {
  890.     register int k;
  891.     register char *s, *t;
  892.     extern chainp assigned_fmts;
  893.  
  894.     if (!np->vfmt_asg) {
  895.         np->vfmt_asg = 1;
  896.         assigned_fmts = mkchain((char *)np, assigned_fmts);
  897.         }
  898.     k = strlen(s = np->fvarname);
  899.     if (k < IDENT_LEN - 4) {
  900.         q->uname_tag = UNAM_IDENT;
  901.         t = q->user.ident;
  902.         }
  903.     else {
  904.         q->uname_tag = UNAM_CHARP;
  905.         q->user.Charp = t = mem(k + 5,0);
  906.         }
  907.     sprintf(t, "%s_fmt", s);
  908.     }
  909.  
  910.  LOCAL Addrp
  911. #ifdef KR_headers
  912. asg_addr(p)
  913.     union Expression *p;
  914. #else
  915. asg_addr(union Expression *p)
  916. #endif
  917. {
  918.     register Addrp q;
  919.  
  920.     if (p->tag != TPRIM)
  921.         badtag("asg_addr", p->tag);
  922.     q = ALLOC(Addrblock);
  923.     q->tag = TADDR;
  924.     q->vtype = TYCHAR;
  925.     q->vstg = STGAUTO;
  926.     q->ntempelt = 1;
  927.     q->isarray = 0;
  928.     q->memoffset = ICON(0);
  929.     fmtname(p->primblock.namep, q);
  930.     return q;
  931.     }
  932.  
  933.  void
  934. startrw(Void)
  935. {
  936.     register expptr p;
  937.     register Namep np;
  938.     register Addrp unitp, fmtp, recp;
  939.     register expptr nump;
  940.     int iostmt1;
  941.     flag intfile, sequential, ok, varfmt;
  942.     struct io_setup *ios;
  943.  
  944.     /* First look at all the parameters and determine what is to be done */
  945.  
  946.     ok = YES;
  947.     statstruct = YES;
  948.  
  949.     intfile = NO;
  950.     if(p = V(IOSUNIT))
  951.     {
  952.         if( ISINT(p->headblock.vtype) ) {
  953.  int_unit:
  954.             unitp = (Addrp) cpexpr(p);
  955.             }
  956.         else if(p->headblock.vtype == TYCHAR)
  957.         {
  958.             if (nioctl == 1 && iostmt == IOREAD) {
  959.                 /* kludge to recognize READ(format expr) */
  960.                 V(IOSFMT) = p;
  961.                 V(IOSUNIT) = p = (expptr) IOSTDIN;
  962.                 ioformatted = FORMATTED;
  963.                 goto int_unit;
  964.                 }
  965.             intfile = YES;
  966.             if(p->tag==TPRIM && p->primblock.argsp==NULL &&
  967.                 (np = p->primblock.namep)->vdim!=NULL)
  968.             {
  969.                 vardcl(np);
  970.                 if(nump = np->vdim->nelt)
  971.                 {
  972.                     nump = fixtype(cpexpr(nump));
  973.                     if( ! ISCONST(nump) ) {
  974.                         statstruct = NO;
  975.                         np->vlastdim = 0;
  976.                         }
  977.                 }
  978.                 else
  979.                 {
  980.                     err("attempt to use internal unit array of unknown size");
  981.                     ok = NO;
  982.                     nump = ICON(1);
  983.                 }
  984.                 unitp = mkscalar(np);
  985.             }
  986.             else    {
  987.                 nump = ICON(1);
  988.                 unitp = (Addrp /*pjw */) fixtype(cpexpr(p));
  989.             }
  990.             if(! isstatic((expptr)unitp) )
  991.                 statstruct = NO;
  992.         }
  993.         else {
  994.             err("unit specifier not of type integer or character");
  995.             ok = NO;
  996.             }
  997.     }
  998.     else
  999.     {
  1000.         err("bad unit specifier");
  1001.         ok = NO;
  1002.     }
  1003.  
  1004.     sequential = YES;
  1005.     if(p = V(IOSREC))
  1006.         if( ISINT(p->headblock.vtype) )
  1007.         {
  1008.             recp = (Addrp) cpexpr(p);
  1009.             sequential = NO;
  1010.         }
  1011.         else    {
  1012.             err("bad REC= clause");
  1013.             ok = NO;
  1014.         }
  1015.     else
  1016.         recp = NULL;
  1017.  
  1018.  
  1019.     varfmt = YES;
  1020.     fmtp = NULL;
  1021.     if(p = V(IOSFMT))
  1022.     {
  1023.         if(p->tag==TPRIM && p->primblock.argsp==NULL)
  1024.         {
  1025.             np = p->primblock.namep;
  1026.             if(np->vclass == CLNAMELIST)
  1027.             {
  1028.                 ioformatted = NAMEDIRECTED;
  1029.                 fmtp = (Addrp) fixtype(p);
  1030.                 V(IOSFMT) = (expptr)fmtp;
  1031.                 if (skiplab)
  1032.                     jumplab = 0;
  1033.                 goto endfmt;
  1034.             }
  1035.             vardcl(np);
  1036.             if(np->vdim)
  1037.             {
  1038.                 if( ! ONEOF(np->vstg, MSKSTATIC) )
  1039.                     statstruct = NO;
  1040.                 fmtp = mkscalar(np);
  1041.                 goto endfmt;
  1042.             }
  1043.             if( ISINT(np->vtype) )    /* ASSIGNed label */
  1044.             {
  1045.                 statstruct = NO;
  1046.                 varfmt = YES;
  1047.                 fmtp = asg_addr(p);
  1048.                 goto endfmt;
  1049.             }
  1050.         }
  1051.         p = V(IOSFMT) = fixtype(p);
  1052.         if(p->headblock.vtype == TYCHAR
  1053.             /* Since we allow write(6,n)        */
  1054.             /* we may as well allow write(6,n(2))    */
  1055.         || p->tag == TADDR && ISINT(p->addrblock.vtype))
  1056.         {
  1057.             if( ! isstatic(p) )
  1058.                 statstruct = NO;
  1059.             fmtp = (Addrp) cpexpr(p);
  1060.         }
  1061.         else if( ISICON(p) )
  1062.         {
  1063.             struct Labelblock *lp;
  1064.             lp = mklabel(p->constblock.Const.ci);
  1065.             if (fmtstmt(lp) > 0)
  1066.             {
  1067.                 fmtp = (Addrp)mkaddcon(lp->stateno);
  1068.                 /* lp->stateno for names fmt_nnn */
  1069.                 lp->fmtlabused = 1;
  1070.                 varfmt = NO;
  1071.             }
  1072.             else
  1073.                 ioformatted = UNFORMATTED;
  1074.         }
  1075.         else    {
  1076.             err("bad format descriptor");
  1077.             ioformatted = UNFORMATTED;
  1078.             ok = NO;
  1079.         }
  1080.     }
  1081.     else
  1082.         fmtp = NULL;
  1083.  
  1084. endfmt:
  1085.     if(intfile) {
  1086.         if (ioformatted==UNFORMATTED) {
  1087.             err("unformatted internal I/O not allowed");
  1088.             ok = NO;
  1089.             }
  1090.         if (recp) {
  1091.             err("direct internal I/O not allowed");
  1092.             ok = NO;
  1093.             }
  1094.         }
  1095.     if(!sequential && ioformatted==LISTDIRECTED)
  1096.     {
  1097.         err("direct list-directed I/O not allowed");
  1098.         ok = NO;
  1099.     }
  1100.     if(!sequential && ioformatted==NAMEDIRECTED)
  1101.     {
  1102.         err("direct namelist I/O not allowed");
  1103.         ok = NO;
  1104.     }
  1105.  
  1106.     if( ! ok ) {
  1107.         statstruct = NO;
  1108.         return;
  1109.         }
  1110.  
  1111.     /*
  1112.    Now put out the I/O structure, statically if all the clauses
  1113.    are constants, dynamically otherwise
  1114. */
  1115.  
  1116.     if (intfile) {
  1117.         ios = io_stuff + iostmt;
  1118.         iostmt1 = IOREAD;
  1119.         }
  1120.     else {
  1121.         ios = io_stuff;
  1122.         iostmt1 = 0;
  1123.         }
  1124.     io_fields = ios->fields;
  1125.     if(statstruct)
  1126.     {
  1127.         ioblkp = ALLOC(Addrblock);
  1128.         ioblkp->tag = TADDR;
  1129.         ioblkp->vtype = ios->type;
  1130.         ioblkp->vclass = CLVAR;
  1131.         ioblkp->vstg = STGINIT;
  1132.         ioblkp->memno = ++lastvarno;
  1133.         ioblkp->memoffset = ICON(0);
  1134.         ioblkp -> uname_tag = UNAM_IDENT;
  1135.         new_iob_data(ios,
  1136.             temp_name("io_", lastvarno, ioblkp->user.ident));            }
  1137.     else if(!(ioblkp = io_structs[iostmt1]))
  1138.         io_structs[iostmt1] = ioblkp =
  1139.             autovar(1, ios->type, ENULL, "");
  1140.  
  1141.     ioset(TYIOINT, XERR, ICON(errbit));
  1142.     if(iostmt == IOREAD)
  1143.         ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(endbit) );
  1144.  
  1145.     if(intfile)
  1146.     {
  1147.         ioset(TYIOINT, XIRNUM, nump);
  1148.         ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) );
  1149.         ioseta(XIUNIT, unitp);
  1150.     }
  1151.     else
  1152.         ioset(TYIOINT, XUNIT, (expptr) unitp);
  1153.  
  1154.     if(recp)
  1155.         ioset(TYIOINT, /* intfile ? XIREC : */ XREC, (expptr) recp);
  1156.  
  1157.     if(varfmt)
  1158.         ioseta( intfile ? XIFMT : XFMT , fmtp);
  1159.     else
  1160.         ioset(TYADDR, intfile ? XIFMT : XFMT, (expptr) fmtp);
  1161.  
  1162.     ioroutine[0] = 's';
  1163.     ioroutine[1] = '_';
  1164.     ioroutine[2] = iostmt==IOREAD ? 'r' : 'w';
  1165.     ioroutine[3] = "ds"[sequential];
  1166.     ioroutine[4] = "ufln"[ioformatted];
  1167.     ioroutine[5] = "ei"[intfile];
  1168.     ioroutine[6] = '\0';
  1169.  
  1170.     putiocall( call1(TYINT, ioroutine, cpexpr((expptr)ioblkp) ));
  1171.  
  1172.     if(statstruct)
  1173.     {
  1174.         frexpr((expptr)ioblkp);
  1175.         statstruct = NO;
  1176.         ioblkp = 0;    /* unnecessary */
  1177.     }
  1178. }
  1179.  
  1180.  
  1181.  
  1182.  LOCAL void
  1183. dofopen(Void)
  1184. {
  1185.     register expptr p;
  1186.  
  1187.     if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
  1188.         ioset(TYIOINT, XUNIT, cpexpr(p) );
  1189.     else
  1190.         err("bad unit in open");
  1191.     if( (p = V(IOSFILE)) )
  1192.         if(p->headblock.vtype == TYCHAR)
  1193.             ioset(TYIOINT, XFNAMELEN, cpexpr(p->headblock.vleng) );
  1194.         else
  1195.             err("bad file in open");
  1196.  
  1197.     iosetc(XFNAME, p);
  1198.  
  1199.     if(p = V(IOSRECL))
  1200.         if( ISINT(p->headblock.vtype) )
  1201.             ioset(TYIOINT, XRECLEN, cpexpr(p) );
  1202.         else
  1203.             err("bad recl");
  1204.     else
  1205.         ioset(TYIOINT, XRECLEN, ICON(0) );
  1206.  
  1207.     iosetc(XSTATUS, V(IOSSTATUS));
  1208.     iosetc(XACCESS, V(IOSACCESS));
  1209.     iosetc(XFORMATTED, V(IOSFORM));
  1210.     iosetc(XBLANK, V(IOSBLANK));
  1211.  
  1212.     putiocall( call1(TYINT, "f_open", cpexpr((expptr)ioblkp) ));
  1213. }
  1214.  
  1215.  
  1216.  LOCAL void
  1217. dofclose(Void)
  1218. {
  1219.     register expptr p;
  1220.  
  1221.     if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
  1222.     {
  1223.         ioset(TYIOINT, XUNIT, cpexpr(p) );
  1224.         iosetc(XCLSTATUS, V(IOSSTATUS));
  1225.         putiocall( call1(TYINT, "f_clos", cpexpr((expptr)ioblkp)) );
  1226.     }
  1227.     else
  1228.         err("bad unit in close statement");
  1229. }
  1230.  
  1231.  
  1232.  LOCAL void
  1233. dofinquire(Void)
  1234. {
  1235.     register expptr p;
  1236.     if(p = V(IOSUNIT))
  1237.     {
  1238.         if( V(IOSFILE) )
  1239.             err("inquire by unit or by file, not both");
  1240.         ioset(TYIOINT, XUNIT, cpexpr(p) );
  1241.     }
  1242.     else if( ! V(IOSFILE) )
  1243.         err("must inquire by unit or by file");
  1244.     iosetlc(IOSFILE, XFILE, XFILELEN);
  1245.     iosetip(IOSEXISTS, XEXISTS);
  1246.     iosetip(IOSOPENED, XOPEN);
  1247.     iosetip(IOSNUMBER, XNUMBER);
  1248.     iosetip(IOSNAMED, XNAMED);
  1249.     iosetlc(IOSNAME, XNAME, XNAMELEN);
  1250.     iosetlc(IOSACCESS, XQACCESS, XQACCLEN);
  1251.     iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN);
  1252.     iosetlc(IOSDIRECT, XDIRECT, XDIRLEN);
  1253.     iosetlc(IOSFORM, XFORM, XFORMLEN);
  1254.     iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN);
  1255.     iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN);
  1256.     iosetip(IOSRECL, XQRECL);
  1257.     iosetip(IOSNEXTREC, XNEXTREC);
  1258.     iosetlc(IOSBLANK, XQBLANK, XQBLANKLEN);
  1259.  
  1260.     putiocall( call1(TYINT,  "f_inqu", cpexpr((expptr)ioblkp) ));
  1261. }
  1262.  
  1263.  
  1264.  
  1265.  LOCAL void
  1266. #ifdef KR_headers
  1267. dofmove(subname)
  1268.     char *subname;
  1269. #else
  1270. dofmove(char *subname)
  1271. #endif
  1272. {
  1273.     register expptr p;
  1274.  
  1275.     if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
  1276.     {
  1277.         ioset(TYIOINT, XUNIT, cpexpr(p) );
  1278.         putiocall( call1(TYINT, subname, cpexpr((expptr)ioblkp) ));
  1279.     }
  1280.     else
  1281.         err("bad unit in I/O motion statement");
  1282. }
  1283.  
  1284. static int ioset_assign = OPASSIGN;
  1285.  
  1286.  LOCAL void
  1287. #ifdef KR_headers
  1288. ioset(type, offset, p)
  1289.     int type;
  1290.     int offset;
  1291.     register expptr p;
  1292. #else
  1293. ioset(int type, int offset, register expptr p)
  1294. #endif
  1295. {
  1296.     offset /= SZLONG;
  1297.     if(statstruct && ISCONST(p)) {
  1298.         register char *s;
  1299.         switch(type) {
  1300.             case TYADDR:    /* stmt label */
  1301.                 s = "fmt_";
  1302.                 break;
  1303.             case TYIOINT:
  1304.                 s = "";
  1305.                 break;
  1306.             default:
  1307.                 badtype("ioset", type);
  1308.             }
  1309.         iob_list->fields[offset] =
  1310.             string_num(s, p->constblock.Const.ci);
  1311.         frexpr(p);
  1312.         }
  1313.     else {
  1314.         register Addrp q;
  1315.  
  1316.         q = ALLOC(Addrblock);
  1317.         q->tag = TADDR;
  1318.         q->vtype = type;
  1319.         q->vstg = STGAUTO;
  1320.         q->ntempelt = 1;
  1321.         q->isarray = 0;
  1322.         q->memoffset = ICON(0);
  1323.         q->uname_tag = UNAM_IDENT;
  1324.         sprintf(q->user.ident, "%s.%s",
  1325.             statstruct ? iob_list->name : ioblkp->user.ident,
  1326.             io_fields[offset + 1]);
  1327.         if (type == TYADDR && p->tag == TCONST
  1328.                    && p->constblock.vtype == TYADDR) {
  1329.             /* kludge */
  1330.             register Addrp p1;
  1331.             p1 = ALLOC(Addrblock);
  1332.             p1->tag = TADDR;
  1333.             p1->vtype = type;
  1334.             p1->vstg = STGAUTO;    /* wrong, but who cares? */
  1335.             p1->ntempelt = 1;
  1336.             p1->isarray = 0;
  1337.             p1->memoffset = ICON(0);
  1338.             p1->uname_tag = UNAM_IDENT;
  1339.             sprintf(p1->user.ident, "fmt_%ld",
  1340.                 p->constblock.Const.ci);
  1341.             frexpr(p);
  1342.             p = (expptr)p1;
  1343.             }
  1344.         if (type == TYADDR && p->headblock.vtype == TYCHAR)
  1345.             q->vtype = TYCHAR;
  1346.         putexpr(mkexpr(ioset_assign, (expptr)q, p));
  1347.         }
  1348. }
  1349.  
  1350.  
  1351.  
  1352.  
  1353.  LOCAL void
  1354. #ifdef KR_headers
  1355. iosetc(offset, p)
  1356.     int offset;
  1357.     register expptr p;
  1358. #else
  1359. iosetc(int offset, register expptr p)
  1360. #endif
  1361. {
  1362.     if(p == NULL)
  1363.         ioset(TYADDR, offset, ICON(0) );
  1364.     else if(p->headblock.vtype == TYCHAR) {
  1365.         p = putx(fixtype((expptr)putchop(cpexpr(p))));
  1366.         ioset(TYADDR, offset, addrof(p));
  1367.         }
  1368.     else
  1369.         err("non-character control clause");
  1370. }
  1371.  
  1372.  
  1373.  
  1374.  LOCAL void
  1375. #ifdef KR_headers
  1376. ioseta(offset, p)
  1377.     int offset;
  1378.     register Addrp p;
  1379. #else
  1380. ioseta(int offset, register Addrp p)
  1381. #endif
  1382. {
  1383.     char *s, *s1;
  1384.     static char who[] = "ioseta";
  1385.     expptr e, mo;
  1386.     Namep np;
  1387.     ftnint ci;
  1388.     int k;
  1389.     char buf[24], buf1[24];
  1390.     Extsym *comm;
  1391.     extern int usedefsforcommon;
  1392.  
  1393.     if(statstruct)
  1394.     {
  1395.         if (!p)
  1396.             return;
  1397.         if (p->tag != TADDR)
  1398.             badtag(who, p->tag);
  1399.         offset /= SZLONG;
  1400.         switch(p->uname_tag) {
  1401.             case UNAM_NAME:
  1402.             mo = p->memoffset;
  1403.             if (mo->tag != TCONST)
  1404.                 badtag("ioseta/memoffset", mo->tag);
  1405.             np = p->user.name;
  1406.             np->visused = 1;
  1407.             ci = mo->constblock.Const.ci - np->voffset;
  1408.             if (np->vstg == STGCOMMON
  1409.             && !np->vcommequiv
  1410.             && !usedefsforcommon) {
  1411.                 comm = &extsymtab[np->vardesc.varno];
  1412.                 sprintf(buf, "%d.", comm->curno);
  1413.                 k = strlen(buf) + strlen(comm->cextname)
  1414.                     + strlen(np->cvarname);
  1415.                 if (ci) {
  1416.                     sprintf(buf1, "+%ld", ci);
  1417.                     k += strlen(buf1);
  1418.                     }
  1419.                 else
  1420.                     buf1[0] = 0;
  1421.                 s = mem(k + 1, 0);
  1422.                 sprintf(s, "%s%s%s%s", comm->cextname, buf,
  1423.                     np->cvarname, buf1);
  1424.                 }
  1425.             else if (ci) {
  1426.                 sprintf(buf,"%ld", ci);
  1427.                 s1 = p->user.name->cvarname;
  1428.                 k = strlen(buf) + strlen(s1);
  1429.                 sprintf(s = mem(k+2,0), "%s+%s", s1, buf);
  1430.                 }
  1431.             else
  1432.                 s = cpstring(np->cvarname);
  1433.             break;
  1434.             case UNAM_CONST:
  1435.             s = tostring(p->user.Const.ccp1.ccp0,
  1436.                 (int)p->vleng->constblock.Const.ci);
  1437.             break;
  1438.             default:
  1439.             badthing("uname_tag", who, p->uname_tag);
  1440.             }
  1441.         /* kludge for Hollerith */
  1442.         if (p->vtype != TYCHAR) {
  1443.             s1 = mem(strlen(s)+10,0);
  1444.             sprintf(s1, "(char *)%s%s", p->isarray ? "" : "&", s);
  1445.             s = s1;
  1446.             }
  1447.         iob_list->fields[offset] = s;
  1448.     }
  1449.     else {
  1450.         if (!p)
  1451.             e = ICON(0);
  1452.         else if (p->vtype != TYCHAR) {
  1453.             NOEXT("non-character variable as format or internal unit");
  1454.             e = mkexpr(OPCHARCAST, (expptr)p, ENULL);
  1455.             }
  1456.         else
  1457.             e = addrof((expptr)p);
  1458.         ioset(TYADDR, offset, e);
  1459.         }
  1460. }
  1461.  
  1462.  
  1463.  
  1464.  
  1465.  LOCAL void
  1466. #ifdef KR_headers
  1467. iosetip(i, offset)
  1468.     int i;
  1469.     int offset;
  1470. #else
  1471. iosetip(int i, int offset)
  1472. #endif
  1473. {
  1474.     register expptr p;
  1475.  
  1476.     if(p = V(i))
  1477.         if(p->tag==TADDR &&
  1478.             ONEOF(p->addrblock.vtype, inqmask) ) {
  1479.             ioset_assign = OPASSIGNI;
  1480.             ioset(TYADDR, offset, addrof(cpexpr(p)) );
  1481.             ioset_assign = OPASSIGN;
  1482.             }
  1483.         else
  1484.             errstr("impossible inquire parameter %s", ioc[i].iocname);
  1485.     else
  1486.         ioset(TYADDR, offset, ICON(0) );
  1487. }
  1488.  
  1489.  
  1490.  
  1491.  LOCAL void
  1492. #ifdef KR_headers
  1493. iosetlc(i, offp, offl)
  1494.     int i;
  1495.     int offp;
  1496.     int offl;
  1497. #else
  1498. iosetlc(int i, int offp, int offl)
  1499. #endif
  1500. {
  1501.     register expptr p;
  1502.     if( (p = V(i)) && p->headblock.vtype==TYCHAR)
  1503.         ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) );
  1504.     iosetc(offp, p);
  1505. }
  1506.